home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Turnbull China Bikeride
/
Turnbull China Bikeride - Disc 2.iso
/
STUTTGART
/
LANG
/
ADA
/
GNAT
/
!gcc
/
adainc
/
2
/
adb
/
a-wtenau
< prev
next >
Wrap
Text File
|
1996-02-12
|
11KB
|
365 lines
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.TEXT_IO.WIDE_TEXT_IO.ENUMERATION_AUX --
-- --
-- B o d y --
-- --
-- $Revision: 1.2 $ --
-- --
-- Copyright (C) 1992,1993,1994, 1995 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System.File_IO; use System.File_IO;
with System.WCh_Con; use System.WCh_Con;
package body Ada.Text_IO.Wide_Text_IO.Enumeration_Aux is
subtype TFT is Ada.Text_IO.File_Type;
-- File type required for calls to routines in Aux
-----------------------
-- Local Subprograms --
-----------------------
procedure Store_Char
(File : File_Type;
WC : Wide_Character;
Buf : out Wide_String;
Ptr : in out Integer);
-- Store a single character in buffer, checking for overflow.
-- These definitions replace the ones in Ada.Characters.Handling, which
-- do not seem to work for some strange not understood reason ??? at
-- least in the OS/2 version.
function To_Lower (C : Character) return Character;
function To_Upper (C : Character) return Character;
function To_Lower (C : Character) return Character is
begin
if C in 'A' .. 'Z' then
return Character'Val (Character'Pos (C) + 32);
else
return C;
end if;
end To_Lower;
function To_Upper (C : Character) return Character is
begin
if C in 'a' .. 'z' then
return Character'Val (Character'Pos (C) - 32);
else
return C;
end if;
end To_Upper;
------------------
-- Get_Enum_Lit --
------------------
procedure Get_Enum_Lit
(File : File_Type;
Buf : out Wide_String;
Buflen : out Natural)
is
ch : int;
WC : Wide_Character;
begin
Buflen := 0;
Load_Skip (TFT (File));
ch := Nextc (TFT (File));
-- Character literal case. If the initial character is a quote, then
-- we read as far as we can without backup (see ACVC test CE3905L)
if ch = Character'Pos (''') then
Get (File, WC);
Store_Char (File, WC, Buf, Buflen);
ch := Nextc (TFT (File));
if ch = LM or else ch = EOF then
return;
end if;
Get (File, WC);
Store_Char (File, WC, Buf, Buflen);
ch := Nextc (TFT (File));
if ch /= Character'Pos (''') then
return;
end if;
Get (File, WC);
Store_Char (File, WC, Buf, Buflen);
-- Similarly for identifiers, read as far as we can, in particular,
-- do read a trailing underscore (again see ACVC test CE3905L to
-- understand why we do this, although it seems somewhat peculiar).
else
-- Identifier must start with a letter. Any wide character value
-- outside the normal Latin-1 range counts as a letter for this.
if ch < 255 and then not Is_Letter (Character'Val (ch)) then
return;
end if;
-- If we do have a letter, loop through the characters quitting on
-- the first non-identifier character (note that this includes the
-- cases of hitting a line mark or page mark).
loop
Get (File, WC);
Store_Char (File, WC, Buf, Buflen);
ch := Nextc (TFT (File));
exit when ch = EOF;
if ch = Character'Pos ('_') then
exit when Buf (Buflen) = '_';
elsif ch = Character'Pos (Ascii.ESC) then
null;
elsif File.WC_Method in WC_Upper_Half_Encoding_Method
and then ch > 127
then
null;
else
exit when Is_Letter (Character'Val (ch))
and then not Is_Digit (Character'Val (ch));
end if;
end loop;
end if;
end Get_Enum_Lit;
-------------------
-- Scan_Enum_Lit --
-------------------
procedure Scan_Enum_Lit
(From : Wide_String;
Start : out Natural;
Stop : out Natural)
is
WC : Wide_Character;
-- Processing for Scan_Enum_Lit
begin
Start := From'First;
loop
if Start > From'Last then
raise End_Error;
elsif Is_Character (From (Start))
and then not Is_Blank (To_Character (From (Start)))
then
exit;
else
Start := Start + 1;
end if;
end loop;
-- Character literal case. If the initial character is a quote, then
-- we read as far as we can without backup (see ACVC test CE3905L
-- which is for the analogous case for reading from a file).
if From (Start) = ''' then
Stop := Start;
if Stop = From'Last then
raise Data_Error;
else
Stop := Stop + 1;
end if;
if From (Stop) in ' ' .. '~'
or else From (Stop) >= Wide_Character'Val (16#80#)
then
if Stop = From'Last then
raise Data_Error;
else
Stop := Stop + 1;
if From (Stop) = ''' then
return;
end if;
end if;
end if;
Stop := Stop - 1;
raise Data_Error;
-- Similarly for identifiers, read as far as we can, in particular,
-- do read a trailing underscore (again see ACVC test CE3905L to
-- understand why we do this, although it seems somewhat peculiar).
else
-- Identifier must start with a letter, any wide character outside
-- the normal Latin-1 range is considered a letter for this test.
if Is_Character (From (Start))
and then not Is_Letter (To_Character (From (Start)))
then
raise Data_Error;
end if;
-- If we do have a letter, loop through the characters quitting on
-- the first non-identifier character (note that this includes the
-- cases of hitting a line mark or page mark).
Stop := Start + 1;
while Stop < From'Last loop
WC := From (Stop + 1);
exit when
Is_Character (WC)
and then
not Is_Letter (To_Character (WC))
and then
not Is_Letter (To_Character (WC))
and then
(WC /= '_' or else From (Stop - 1) = '_');
Stop := Stop + 1;
end loop;
end if;
end Scan_Enum_Lit;
---------
-- Put --
---------
procedure Put
(File : File_Type;
Item : Wide_String;
Width : Field;
Set : Type_Set)
is
Actual_Width : constant Integer :=
Integer'Max (Integer (Width), Item'Length);
begin
Check_On_One_Line (TFT (File), Actual_Width);
if Set = Lower_Case and then Item (1) /= ''' then
declare
Iteml : Wide_String (Item'First .. Item'Last);
begin
for J in Item'Range loop
if Is_Character (Item (J)) then
Iteml (J) :=
To_Wide_Character (To_Lower (To_Character (Item (J))));
else
Iteml (J) := Item (J);
end if;
end loop;
Put (File, Iteml);
end;
else
Put (File, Item);
end if;
for J in 1 .. Actual_Width - Item'Length loop
Put (File, ' ');
end loop;
end Put;
----------
-- Puts --
----------
procedure Puts
(To : out Wide_String;
Item : in Wide_String;
Set : Type_Set)
is
Ptr : Natural;
begin
if Item'Length > To'Length then
raise Layout_Error;
else
Ptr := To'First;
for J in Item'Range loop
if Set = Lower_Case
and then Item (1) /= '''
and then Is_Character (Item (J))
then
To (Ptr) :=
To_Wide_Character (To_Lower (To_Character (Item (J))));
else
To (Ptr) := Item (J);
end if;
Ptr := Ptr + 1;
end loop;
while Ptr <= To'Last loop
To (Ptr) := ' ';
Ptr := Ptr + 1;
end loop;
end if;
end Puts;
----------------
-- Store_Char --
----------------
procedure Store_Char
(File : File_Type;
WC : Wide_Character;
Buf : out Wide_String;
Ptr : in out Integer)
is
begin
if Ptr = Buf'Last then
raise Data_Error;
else
Ptr := Ptr + 1;
Buf (Ptr) := WC;
end if;
end Store_Char;
end Ada.Text_IO.Wide_Text_IO.Enumeration_Aux;
